home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / printers / print-modules.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  4.1 KB  |  131 lines  |  [TEXT/CCL2]
  1. ;;; print-modules.scm -- print routines for module-related AST structures
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  6 Jan 1992
  5. ;;;
  6. ;;;
  7. ;;; This file corresponds to the file ast/modules.scm.
  8.  
  9. ;;; Note: by default, only the module name is printed.  To print the
  10. ;;; full module, the function print-full-module must be called.
  11.  
  12. (define *print-abbreviated-modules* '#t)
  13.  
  14. (define-ast-printer module (object xp)
  15.  (if *print-abbreviated-modules*
  16.      (begin
  17.        (write-string (module-type-name object) xp)
  18.        (write-string (symbol->string (module-name object)) xp))
  19.      (do-print-full-module object xp)))
  20.  
  21. (define (module-type-name mod)
  22.   (if (interface-module? mod)
  23.       "interface "
  24.       "module "))
  25.  
  26. (define (print-full-module object . maybe-stream)
  27.   (let ((stream  (if (not (null? maybe-stream))
  28.              (car maybe-stream)
  29.              (current-output-port))))
  30.     (dynamic-let ((*print-abbreviated-modules* '#f))
  31.        (pprint object stream))))
  32.  
  33. (define (do-print-full-module object xp)
  34.  (dynamic-let ((*print-abbreviated-modules* '#t))
  35.   (let ((modid    (module-name object))
  36.     (exports  (module-exports object))
  37.     (body     (append (module-imports object)
  38.               (module-fixities object)
  39.               (module-synonyms object)
  40.               (module-algdatas object)
  41.               (module-classes object)
  42.               (module-instances object)
  43.               (if (or (not (module-default object))
  44.                   (eq? (module-default object)
  45.                        *standard-module-default*))
  46.                   '()
  47.                   (list (module-default object)))
  48.               (module-decls object))))
  49.     (write-string (module-type-name object) xp)
  50.     (write-modid modid xp)
  51.     (when (not (null? exports))
  52.       (write-whitespace xp)
  53.       (write-commaized-list exports xp))
  54.     (write-wheredecls body xp))))
  55.  
  56. (define-ast-printer import-decl (object xp)
  57.   (let ((modid     (import-decl-module-name object))
  58.     (mode      (import-decl-mode object))
  59.     (specs     (import-decl-specs object))
  60.     (renamings (import-decl-renamings object)))
  61.     (with-ast-block (xp)
  62.       (write-string "import " xp)
  63.       (write-modid modid xp)
  64.       (if (eq? mode 'all)
  65.       (when (not (null? specs))
  66.         (write-whitespace xp)
  67.         (write-string "hiding " xp)
  68.         (write-commaized-list specs xp))
  69.       (begin
  70.         (write-whitespace xp)
  71.         (write-commaized-list specs xp)))
  72.       (when (not (null? renamings))
  73.     (write-whitespace xp)
  74.     (write-string "renaming " xp)
  75.     (write-commaized-list renamings xp))
  76.       )))
  77.  
  78. (define-ast-printer entity-module (object xp)
  79.   (write-modid (entity-name object) xp)
  80.   (write-string ".." xp))
  81.  
  82. (define-ast-printer entity-var (object xp)
  83.   (write-varid (entity-name object) xp))
  84.  
  85. (define-ast-printer entity-con (object xp)
  86.   (write-tyconid (entity-name object) xp))
  87.  
  88. (define-ast-printer entity-abbreviated (object xp)
  89.   (write-tyconid (entity-name object) xp)
  90.   (write-string "(..)" xp))
  91.  
  92. (define-ast-printer entity-class (object xp)
  93.   (with-ast-block (xp)
  94.     (write-tyclsid (entity-name object) xp)
  95.     (write-whitespace xp)
  96.     (write-delimited-list (entity-class-methods object) xp
  97.               (function write-varid) "," "(" ")")))
  98.  
  99. (define-ast-printer entity-datatype (object xp)
  100.   (with-ast-block (xp)
  101.     (write-tyconid (entity-name object) xp)
  102.     (write-whitespace xp)
  103.     (write-delimited-list (entity-datatype-constructors object) xp
  104.               (function write-conid) "," "(" ")")))
  105.  
  106.  
  107. (define-ast-printer renaming (object xp)
  108.   (with-ast-block (xp)
  109.     (write-varid-conid (renaming-from object) xp)
  110.     (write-string " to" xp)
  111.     (write-whitespace xp)
  112.     (write-varid-conid (renaming-to object) xp)))
  113.  
  114. ;;; *** Should it omit precedence if it's 9?
  115.  
  116. (define-ast-printer fixity-decl (object xp)
  117.   (let* ((fixity         (fixity-decl-fixity object))
  118.      (associativity  (fixity-associativity fixity))
  119.      (precedence     (fixity-precedence fixity))
  120.      (ops            (fixity-decl-names object)))
  121.     (with-ast-block (xp)
  122.       (cond ((eq? associativity 'l)
  123.          (write-string "infixl " xp))
  124.         ((eq? associativity 'r)
  125.          (write-string "infixr " xp))
  126.         ((eq? associativity 'n)
  127.          (write-string "infix " xp)))
  128.       (write precedence xp)
  129.       (write-whitespace xp)
  130.       (write-delimited-list ops xp (function write-varop-conop) "," "" ""))))
  131.